home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
PowerLisp 2.01
/
PowerLisp 2.01 ƒ
/
Library
/
compiler_ppc.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1996-05-22
|
62KB
|
2,272 lines
;;;
;;; PowerLisp 2.0
;;; Copyright © 1996 Roger Corman. All rights reserved.
;;; PowerPC Compiler source
;;;
;
; Source code for compiler.
; This is included in the "COMPILER" package.
;
(eval-when (:compile-toplevel :load-toplevel :execute)
(provide :compiler)
(in-package :compiler)
(require :assembler)
(use-package :assembler)
(export '(compiler::compile-top-level-form)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun assembly-start (stream char)
(cons 'compiler::push-assembly-instructions (read-delimited-list #\] stream)))
(defun assembly-end (stream char) nil)
(set-macro-character #\[ #'assembly-start)
(set-macro-character #\] #'assembly-end))
;
; We do an eval-when on the entire file so that we get the
; performance benefits immediately
;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *assemble-code* t)
(defvar *asm* nil)
(defvar *lex-counter* 0)
(defvar *references* nil)
(defvar *function-name* nil)
(defvar *function-entry-label* nil)
(defvar *cleanup-forms-stack* nil)
(defvar *lambda-list* nil)
(defvar *arg-count* 0)
(defvar *last-call-was-values* nil)
(defvar *returned-multiple-values* nil)
(defvar *environment* nil)
(defvar *embedded-lambdas* nil)
(defvar *lambda-special-vars* nil)
(defvar *lambda-declarations* nil)
(defvar *lambda-special-decs* nil)
(defvar *compile-time-too-mode* nil)
(defvar *compile-print* nil)
(defvar *compile-output-file* nil)
(defvar *symbol-table* nil)
(defvar *last-call-was-tail-recursion* nil)
(defvar *max-call-parameters* 6)
(defvar *current-call-index* 0)
(defconstant *jmp_buf-size* 70) ;; 70 longs are stored
;; top level forms which we will output the names of while compiling
;; if *compile-print* is true
(defvar *compiler-print-forms*
'(defun defmacro defstruct defclass defvar defparameter defconstant))
(defun compile-it (name &optional lambda &aux (macro nil))
(unless (typep name 'symbol) (error "Function name expected"))
(unless lambda (setf lambda (function-definition (symbol-function name))))
(setq macro (macro-function name))
(unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
(setq *assemble-code* t)
(if macro
(setf (macro-function name) (compile-lambda lambda name))
(setf (symbol-function name) (compile-lambda lambda name)))
name)
(defun compile-without-assembling-it (name &optional lambda &aux (macro nil))
(unless (typep name 'symbol) (error "Function name expected"))
(unless lambda (setf lambda (function-definition (symbol-function name))))
(setq macro (macro-function name))
(unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
(setq *assemble-code* nil)
(compile-lambda lambda name))
(defun compile-the-file (input-file output-file print)
(setq *assemble-code* t)
(do* ((infile (open input-file :direction :input))
(*compile-output-file*
(progn
(delete-file output-file)
(open output-file
:direction :output
:if-exists :overwrite
:if-does-not-exist :create)))
(*compile-print* print)
(*package* *package*)
(*readtable* *readtable*)
(*symbol-table* (make-hash-table :size 500))
(input-expression (read infile nil 'Eof nil) (read infile nil 'Eof nil))
code
return-value)
((eq input-expression 'Eof)
(close infile)
(set-file-type *compile-output-file* "FASL")
(close *compile-output-file*)
output-file)
(process-top-level-forms (list input-expression))))
;;
;; The following logic is taken from CLTL2 pp.90-91
;;
(defun process-top-level-forms (forms &aux code return-value print-form)
(dolist (f forms)
(setq print-form nil)
(if (not (consp f)) (go continue)) ;; no need to process non-list forms
(if (and *compile-print*
(member (car f) *compiler-print-forms*)
(consp (cdr f)))
(setq print-form (list (car f) (cadr f) "...")))
; (format t "print-form = ~A~%" print-form)
; (file-flush)
(if (macro-function (car f)) ;; if it is a macro expand it
(progn
(setq f (macroexpand f))
(if (not (consp f)) (go continue)))) ;; no need to process non-list forms
;; watch for some special forms
(if (special-form-p (car f))
(progn
;; if a progn or locally special form, recurse
(if (or (eq (car f) 'common-lisp::progn)
(eq (car f) 'common-lisp::locally))
(progn
(process-top-level-forms (cdr f))
(go continue)))
;; if compiler-let, macrolet or symbol-macrolet
(if (or (eq (car f) 'common-lisp::compiler-let)
(eq (car f) 'common-lisp::macrolet)
(eq (car f) 'common-lisp::symbol-macrolet))
(progn
(error "Compiler does not support special form: ~A" (car f))
(process-top-level-forms (cdr f))
(go continue)))
;; if eval-when
(if (eq (car f) 'common-lisp::eval-when)
(progn
(compile-top-level-eval-when-form f)
(go continue)))))
;; else it is not a special case
;; now compile it
(setq code (compile-top-level-form f))
(%write-code-to-stream code *compile-output-file* *symbol-table*)
;; evaluate the form if compile-time-too mode
(if *compile-time-too-mode*
(setq return-value (funcall code)))
continue
(if print-form
(progn
(format t "~A~%" print-form)
(file-flush)))))
(defun compile-top-level-eval-when-form (form)
(if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
(error "'eval-when' form missing condition list."))
(let* ((conditions (cadr form))
(load-condition
(or (member 'common-lisp::load conditions)
(member :load-toplevel conditions)))
(eval-condition
(or (member 'common-lisp::eval conditions)
(member :execute conditions)))
(compile-condition
(or (member 'common-lisp::compile conditions)
(member :compile-toplevel conditions))))
(if load-condition
(if (or compile-condition
(and *compile-time-too-mode* eval-condition))
(let ((*compile-time-too-mode* t))
(process-top-level-forms (cddr form)))
(let ((*compile-time-too-mode* nil))
(process-top-level-forms (cddr form))))
;; load not specified
(if (or compile-condition
(and *compile-time-too-mode* eval-condition))
(eval form)))))
;;
;; The cleanup forms stack needs to be maintained for use in non-local
;; lexically scoped exit situations. Specifically, GO with a target outside
;; the current construct, and RETURN-FROM when exiting an external construct.
;; Note that THROW targets are dynamic, not lexical, and therefore cannot
;; be handled at compile time. They are handled via a different mechanism, a
; run-time stack. Lexically scoped exits are better handled at compile time,
;; both for efficiency (a big concern, because GO is the primary iteration
;; facility) and because the lexical scoping is currently only known at
;; compile-time. In other words, a run-time lexical environment is not maintained
;; for compiled code, and for efficiency reasons it would be better not to have
;; to.
;;
;; Entries on the cleanup forms stack include:
;;
;; (BLOCK block-name block-exit-label)
;; (TAGBODY (local-tag-1 . local-label-1) (local-tag-2 . local-label-2) ...)
;; (LET (local-var-1 . index1) (local-var-2 . index2) ...)
;; (the LET form is used by both LET *and* LET* forms)
;; (CATCH catch-tag)
;; (UNWIND-PROTECT <compiled code to be included>)
;;
(defconstant *lambda-list-keywords*
'( &optional
&rest
&key
&aux
&allow-other-keys
&whole
&body ))
;; the following aren't allowed in lambda function declarations
;; (only in macros, which will be expanded before we see them)
(defconstant *unsupported-lambda-list-keywords*
'( &whole
&body ))
(defparameter *num-saved-registers* 6)
(defparameter *saved-register-bytes* (* *num-saved-registers* 4))
(defparameter *linkage-bytes* 24)
(defparameter *standard-reg-bytes* (* 8 4)) ;; space to save r3-r10
(defparameter *fixed-linkage-bytes*
(+ *saved-register-bytes* *linkage-bytes* *standard-reg-bytes*))
;;
;; Set up square braces as assembly delimiters for this module
;; This helps to clearly distinguish the generated code from the
;; surrounding stuff.
;;
(defun push-assembly-instructions (&rest instructions)
(dolist (x instructions)
(push x *asm*)))
(defun push-cleanup (x) (push x *cleanup-forms-stack*))
(defun pop-cleanup () (pop *cleanup-forms-stack*))
;; We use the following registers:
;; R0 : scratch register
;; R3 : stores returned value
;; R26 : temporary variable
;; R27 : pointer to function's parameters
;; R28 : used to keep current return value
;; R29 : points to parameter area for calls we make
;; R30 : points to lexical storage for the function
;; R31 : points to function's environment (variables with indefinite extent)
;;
;; We do not need to save R0 or R3
;; We *do* need to save R11 - R14.
;;
;;
;; compile-top-level-form (form &optional (assemble t))
;; Given an arbitrary lisp form, returns a compiled function
;; equivalent to it.
;;
(defun compile-top-level-form (form)
(let* (
;; Establish local bindings of these special variables
;; so that this function can be entered recursively.
;;
(*asm* nil)
(*lex-counter* 0)
(*references* nil)
(*function-entry-label* (gensym))
(*last-call-was-values* nil)
(*returned-multiple-values* nil)
(*cleanup-forms-stack* nil)
(*environment* nil)
(*max-call-parameters* 6)
(*current-call-index* 0)
(*embedded-lambdas* (find-lambdas form)))
;; emit code for function prolog
(emit-prolog)
;; compile the form
(compile-form form)
;; make sure bogus multiple values don't get returned
(unless (or *last-call-was-values* *returned-multiple-values*)
(kill-multiple-values))
(emit-epilog)
;; if we don't want to assemble it, exit here
(if *assemble-code*
(return (assemble *asm* *references* nil))
(return *asm*))))
;;---------------------------------------------------
;;
;; compile-lambda (lambda)
;; Given a lambda expression, returns a compiled function.
;;
(defun compile-lambda (lambda func-name)
(check-lambda lambda) ;; make sure we can compile it
(let* ((*asm* nil)
(*references* nil)
(*function-name* func-name)
(*function-entry-label* (gensym))
(*cleanup-forms-stack* nil)
(*lambda-list* (cadr lambda))
(*last-call-was-values* nil)
(*returned-multiple-values* nil)
(*environment* *environment*) ;; inherit from enclosing expression
(*embedded-lambdas* (find-lambdas (cdr lambda)))
(*arg-count* 0)
(*lex-counter* 0)
(*lambda-special-vars* nil)
(*lambda-declarations* nil)
(*lambda-special-decs* nil)
(*last-call-was-tail-recursion* nil)
(*max-call-parameters* 6)
(*current-call-index* 0)
(forms (cddr lambda))
(new-vars (collect-new-vars *lambda-list*))
(lex-vars nil)
(aux-args (aux-arguments *lambda-list*)))
;; look for declarations
(do ((f forms (cdr f)))
((null f) (setq forms f))
(if (and (consp (car f)) (eq (caar f) 'declare))
(push (car f) *lambda-declarations*)
(progn (setq forms f) (return))))
;; search declarations for special declarations
(dolist (declaration *lambda-declarations*)
(dolist (dec-form (cdr declaration))
(if (and (consp dec-form) (eq (car dec-form) 'special))
(setq *lambda-special-decs*
(append (cdr dec-form) *lambda-special-decs*)))))
(setq lex-vars
(remove-if
#'(lambda (x)
(or (member x *lambda-special-decs*)
(special-variable-p x)))
new-vars
:key #'car))
(add-lexical-variables lex-vars)
(emit-prolog)
(compile-lambda-args)
(create-runtime-bindings) ;; create necessary heap bindings
;; handle aux variables by just adding an implicit let* form
(if aux-args
(setf forms `((let* ,aux-args ,@forms))))
(compile-nil) ;; store NIL as default return value
(if *lambda-special-vars*
(compile-unwind-protect-form
`(unwind-protect
(block ,func-name ,@forms)
($pop-special-bindings ',*lambda-special-vars*)))
;; else execute the forms directly
;; compile the forms as a block
(compile-block-form `(block ,func-name ,@forms)))
#|
;; eliminate tail recursion
(if nil ;; *last-call-was-tail-recursion*
(let* ((num-call-instructions (- (length *asm*) (length *last-call-was-tail-recursion*)))
(call-instructions (reverse (subseq *asm* 0 num-call-instructions)))
(find-top-label (gensym))
(copy-label))
;; strip off the function call
(setq *asm* *last-call-was-tail-recursion*)
;; push all instructions up to the bsr
(do ((inst (pop call-instructions) (pop call-instructions)))
((or (null call-instructions)
(and (consp inst) (eq (car inst) 'assembler::bsr))))
(push inst *asm*))
;; move passed params to outer stack frame
;; add return address and branch instruction to simulate jsr
[
`(move.l a7 a3)
;; position a3 above top of parameter frame
find-top-label
`(tst.l (a3+))
`(bne ,find-top-label)
;; copy parameters
copy-label
`(move.l (-a3) (-a2))
`(move.l a3 d0) ;; haven't implemented cmpa.l instruction yet
`(cmp.l a7 d0)
`(bne ,copy-label)
`(unlk a6)
`(move.l (a7) a0) ; get return address in a0
`(lea (a2 4) a7)
`(move.l a7 (-a7))
`(move.l a0 (-a7))
`(bra ,*function-entry-label*)
]
;; add the rest of the instructions
(do ((inst (pop call-instructions) (pop call-instructions)))
((null call-instructions))
(push inst *asm*))))
|#
;; make sure bogus multiple values don't get returned
(unless (or *last-call-was-values* *returned-multiple-values*)
(kill-multiple-values))
(emit-epilog)
(pop-cleanup)
(if *assemble-code*
(return (assemble *asm* *references* nil))
(return *asm*))))
(defun compile-lambda-args ()
(compile-lambda-required-args)
(compile-lambda-optional-args)
(compile-lambda-rest-args)
(check-no-more-args)
(compile-lambda-key-args))
(defun collect-new-vars (lambda-list)
(let ((new-vars nil)(supplied_p_vars nil))
(dolist (n lambda-list) ;; add lexical vars
(if (not (member n *lambda-list-keywords*))
(progn
(if (consp n)
(progn
(if (>= (length n) 3) ;; get supplied_p symbols
(push (caddr n) supplied_p_vars))
(push (cons (car n) *lex-counter*) new-vars))
(push (cons n *lex-counter*) new-vars))
(incf *lex-counter*))))
(dolist (n supplied_p_vars)
(push (cons n *lex-counter*) new-vars) ;; these need to go on the end
(incf *lex-counter*))
(nreverse new-vars)))
;; emit code for start of function
(defun emit-prolog ()
;; [
;; `(mflr r0)
;; `(stw r0 (sp 8)) ; store link register on stack
;; `(stmw r27, -20(SP)) ; save R27 - R31 on stack
;; `(stwu sp (sp ,(- (+ 20 24 ???(* *lex-counter* 4)))))
;; ]
(if (or *embedded-lambdas* (environment-not-empty))
[
`(bl 4) ; put current pc in link register
`(mflr r4) ; r0 = pc
`(addi r31 r4 -28)
`(lwz r31 (r31)) ; r31 = pointer to environment (just before code)
])
[
`(mr r27 r3) ; r27 = pointer to parameters - 4
`(addi r27 r27 -4)
`(addi r30 sp
,(+ *standard-reg-bytes* *linkage-bytes*)) ; set up local storage pointer
])
;; emit code for end of function
(defun emit-epilog ()
(let* ((lex-bytes (* (+ *lex-counter* *max-call-parameters*) 4))
(var-bytes (* *lex-counter* 4))
(frame-size (+ *fixed-linkage-bytes* lex-bytes)))
[
`(mr r3 r28) ; return value in r3
`(addi sp sp ,frame-size) ; restore stack
`(lmw r26 (sp ,(- *saved-register-bytes*))) ; restore register R26-R31
`(lwz r0 (sp 8))
`(mtlr r0)
`(blr)
]
(setq *asm* (nreverse *asm*))
;; These last instructions get pushed onto the beginning
;; of the (now-reversed) instructions. Therefore they are reversed
;; here to come out in the right order.
[
`(addi r29 sp ,(+ *standard-reg-bytes* *linkage-bytes* var-bytes)) ;; set up param area
`(stwu sp (sp ,(- frame-size))) ; allocate stack space
`(stmw r26 (sp ,(- *saved-register-bytes*))) ; save R26 - R31 on stack
`(stw r0 (sp 8)) ; store link register on stack
`(mflr r0)
*function-entry-label*
]))
;; Make sure there are no more arguments.
(defun check-no-more-args ()
(if (not (or (rest-arguments *lambda-list*) (key-arguments *lambda-list*)))
[
`(lwzu r3 (r27 4)) ; get argument
`($CALL #'common-lisp::%checkNull) ; signal error if extra argument
]))
;;
;; compile-lambda-required-args
;; Generates code to initialize required argumensts.
;;
(defun compile-lambda-required-args ()
(dolist (sym (required-arguments *lambda-list*))
[
`(lwzu r3 (r27 4)) ; get argument
`($CALL #'common-lisp::%checkObj) ; signal error if argument missing
`(stw r3 (r30 ,(* *arg-count* 4)))
]
(if (or (special-variable-p sym) (member sym *lambda-special-decs*))
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
(push sym *lambda-special-vars*)
[
`($LOAD-OBJ r3 ',sym)
`(stw r3 (r29 ,(* counter 4)))
`(lwz r0 (r30 ,(* *arg-count* 4)))
`(stw r0 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'common-lisp::$push-special-bindings)
]))
(incf *arg-count*)))
;;
;; compile-lambda-optional-args
;; Generates code to initialize optional argumensts.
;;
(defun compile-lambda-optional-args () nil)
(defun compile-lambda-rest-args () nil)
(defun compile-lambda-key-args () nil)
(defun compile-lambda-optional-args ()
(dolist (sym (optional-arguments *lambda-list*))
;; initialize optional variable
(let ((else-label (gensym))
(end-label (gensym)))
[
`(lwz r3 (r27 4)) ;; is there an argument
`(cmpwi r3 0)
`(beq ,else-label)
]
(if (and (consp sym) (>= (length sym) 3))
(compile-form `(setq ,(caddr sym) t))) ;; set supplied_p
[
`(lwzu r3 (r27 4)) ;; is there an argument
`(stw r3 (r30 ,(* *arg-count* 4)))
`(b ,end-label)
else-label
]
;; else do default initialization
(if (and (consp sym) (>= (length sym) 3))
(compile-form `(setq ,(caddr sym) nil))) ;; set supplied_p
(if (and (consp sym) (cdr sym))
(progn
;; [
;; `(movem.l a0 a2 a3 d0 (-a7))
;; ]
(compile-form (cadr sym))
[
;; `(movem.l (a7+) a0 a2 a3 d0)
`(stw r28 (r30 ,(* *arg-count* 4)))
])
;; else
[
`($LOAD-OBJ r3 'nil)
`(stw r3 (r30 ,(* *arg-count* 4)))
])
[
end-label
])
(if (or (special-variable-p sym) (member sym *lambda-special-decs*))
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
(push sym *lambda-special-vars*)
[
`($LOAD-OBJ r3 ',sym)
`(stw r3 (r29 ,(* counter 4)))
`(lwz r3 (r30 ,(* *arg-count* 4)))
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::$push-special-bindings)
]))
(incf *arg-count*)))
;;
;; compile-lambda-rest-args
;; Generates code to initialize rest arguments.
;; We allow more than one.
;;
(defun compile-lambda-rest-args ()
(let* ((rest-args (rest-arguments *lambda-list*)))
(if rest-args
[
`(addi r3 r27 4)
`($CALL #'list)
])
(dolist (sym rest-args)
[
`(stw r3 (r30 ,(* *arg-count* 4)))
]
(if (or (special-variable-p sym) (member sym *lambda-special-decs*))
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
(push sym *lambda-special-vars*)
[
`($LOAD-OBJ r3 ',sym)
`(stw r3 (r29 ,(* counter 4)))
`(lwz r3 (r30 ,(* *arg-count* 4)))
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::$push-special-bindings)
]))
(incf *arg-count*))))
;;
;; compile-lambda-key-args
;; Generates code to initialize key argumensts.
;;
(defun compile-lambda-key-args ()
(dolist (n (key-arguments *lambda-list*))
(let* ((loop-label (gensym))
(exit-label (gensym))
(not-found-label (gensym))
lex-var
default-init
key-symbol)
(if (consp n)
(setq lex-var (car n))
(setq lex-var n))
(if (and (consp n) (cdr n))
(setq default-init (cadr n))
(setq default-init nil))
(setq key-symbol
(intern (symbol-name lex-var) (find-package :keyword)))
[
`(mr r26 r27) ; r26 = current argument location
`($LOAD-OBJ r3 ',key-symbol)
loop-label
`(lwzu r0 (r26 4)) ; is there an argument?
`(cmpwi r0 0)
`(beq ,not-found-label)
`(cmpw r3 r0)
`(bne ,loop-label)
`(lwzu r3 (r26 4)) ; make sure there is another argument
`($CALL #'cl::%checkObj)
`(stw r3 (r30 ,(* *arg-count* 4)))
`(b ,exit-label)
not-found-label
]
(compile-form default-init)
[
`(stw r28 (r30 ,(* *arg-count* 4)))
exit-label
]
(if (or (special-variable-p n) (member n *lambda-special-decs*))
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
(push n *lambda-special-vars*)
[
`($LOAD-OBJ r3 ',n)
`(stw r3 (r29 ,(* counter 4)))
`(lwz r3 (r30 ,(* *arg-count* 4)))
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::$push-special-bindings)
]))
(incf *arg-count*))))
(defun compile-form (form)
(setq *last-call-was-values* nil)
(setq *last-call-was-tail-recursion* nil)
(cond
((null form) (compile-nil))
((symbolp form) (compile-symbol form))
((not (consp form)) (compile-literal-form form))
(t (compile-list-form form))))
(defun compile-list-form (form)
(let ((firstobj (car form)))
(cond
((consp firstobj) (compile-explicit-lambda form))
((not (symbolp firstobj))
(error "Can't compile form--does not begin with a symbol"))
((macro-function firstobj) (compile-form (macroexpand form)))
((special-form-p firstobj) (compile-special-form form))
((eq firstobj 'common-lisp::values) (compile-values-form form))
(t (compile-function-call-form form)))))
(defun compile-special-form (form)
(case (car form)
(quote (compile-quote-form form))
(if (compile-if-form form))
(tagbody (compile-tagbody-form form))
(go (compile-go-tag form))
(setq (compile-setq-form form))
(block (compile-block-form form))
(return-from (compile-return-from-form form))
(progn (compile-progn-form form))
(let (compile-let-form form))
(let* (compile-let*-form form))
(flet (compile-flet-form form))
(labels (compile-labels-form form))
(function (compile-function-special-form form))
(catch (compile-catch-form form))
(throw (compile-throw-form form))
(unwind-protect (compile-unwind-protect-form form))
(multiple-value-call (compile-multiple-value-call-form form))
(eval-when (compile-eval-when-form form))
(multiple-value-prog1 (compile-multiple-value-prog1-form form))
(the (compile-the-form form))
(declare nil)
(otherwise (error "Special form not supported: ~A~%" (car form)))))
(defun compile-explicit-lambda (form)
(if (not (eq 'lambda (caar form)))
(error "The first element of the expression: ~A is a list but it
isn't a lambda expression~%" (car form)))
(compile-form `(funcall (function ,(car form)) ,@(cdr form))))
(defun compile-symbol (sym)
(let ((temp (find-lex sym))) ; check for lexical variable
(if temp
(if (integerp (cdr temp))
[
`(lwz r28 (r30 ,(* (cdr temp) 4)))
]
;; else
[
`(lwz r28 (r30 ,(* (cadr temp) 4)))
`($CDR r28 r28)
])
;; else see if it is in the inherited environment
(if (find-in-environment sym)
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
[
`(stw r31 (r29 ,(* counter 4)))
`($LOAD-OBJ r3 ',sym)
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%environment-get-value)
`(mr r28 r3)
])
;; else assume special variable
(compile-function-call-form `(symbol-value ',sym))))))
(defun compile-if-form (form)
(let ((else-label (gensym))
(end-label (gensym))
(test-form (cadr form))
(then-form (caddr form))
(else-form (cdddr form)))
(compile-form test-form)
[
`($LOAD-OBJ r3 'nil)
`(cmpw r3 r28)
`(beq ,else-label)
]
(compile-form then-form)
(if (consp else-form)
[
`(b ,end-label)
])
[
else-label
]
(if (consp else-form)
(compile-form (car else-form)))
[
end-label
]))
(defun compile-tagbody-form (form)
(let ((tags nil))
;; go through list once collecting tags
(dolist (n (cdr form))
(if (or (integerp n) (symbolp n))
(push (cons n (gensym)) tags)))
(push-cleanup (cons 'tagbody tags))
(dolist (n (cdr form))
(if (or (integerp n) (symbolp n))
(push (cdr (assoc n tags)) *asm*)
;; else it is a form to be evaluated
(compile-form n)))
(pop-cleanup)))
(defun compile-go-tag (form)
(let ((tag (cadr form)))
(if (not (or (integerp tag) (symbolp tag)))
(error "Invalid go tag encountered"))
(if (not (find-go-tag tag)) ;; if the tag is not already defined
(error "Tag not defined in this scope"))
;; peel off cleanup stack
(let ((dest (find-go-tag-tagbody tag)))
(dolist (f *cleanup-forms-stack*)
(if (eq f dest) (return)) ;; returns from the dolist block
(case (car f)
(unwind-protect
;; include cleanup code
(let ((cleanup-code (cdr f)))
(dolist (n cleanup-code)
(push n *asm*))))
(catch
;; remove dynamic catch tag
[
`($CALL #'cl::%popCatcher) ;; restore result
]))))
[
`(b ,(cdr (find-go-tag tag)))
]))
(defun compile-setq-form (form)
(do ((f (cdr form) (cddr f)) var val temp)
((endp f))
(setq var (car f))
(setq val (cadr f))
(setf temp (find-lex var)) ; check for lexical variable
(if temp
(progn
(compile-form val)
(if (integerp (cdr temp))
[
`(stw r28 (r30 ,(* (cdr temp) 4)))
]
;; else
[
`(lwz r3 (r30 ,(* (cadr temp) 4)))
`($SETCDR r3 r28)
]))
;; else look in the inherited environment
(if (find-in-environment var)
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 4))
(compile-form val)
[
`(stw r31 (r29 ,(* (+ counter 0) 4)))
`($LOAD-OBJ r3 ',var)
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(stw r28 (r29 ,(* (+ counter 2) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 3) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%environment-set-value)
`(mr r28 r3)
])
;; else call set function
(compile-form `(set ',var ,val))))))
(defun compile-quote-form (form)
(compile-literal-form (cadr form)))
(defun compile-block-form (form)
(let ((block-name (cadr form))
(block-forms (cddr form))
(exit-label (gensym)))
(push-cleanup (list 'block block-name exit-label))
;; in case an embedded lambda has a (return-from block-name) in it
(if (referenced-by-embedded-lambdas block-name)
(progn (compile-catch-form
`(catch ',block-name (progn ,@block-forms)))
(warn "had to compile a catch form for a block header: ~A" block-name))
(dolist (f block-forms)
(compile-form f)))
[
exit-label
]
(pop-cleanup)))
(defun compile-return-from-form (form)
(let ((block-name (cadr form))
(retval nil)
temp)
(if (consp (cddr form))
(setq retval (caddr form)))
(if (null block-name)
(setq temp (find-any-block))
;; else
(setq temp (find-block block-name)))
(if temp
(progn
(compile-form retval)
;; if we are returning multiple values from a block
;; just allow them to be returned from entire lambda
;; since we can't be sure whether they should propogate
;; to the end
(if (and (consp retval) (eq (car retval) 'values))
(setq *returned-multiple-values* t)))
(let ((throw-tag `',block-name)
(throw-form retval)
(counter *current-call-index*))
(parameter-ceiling (+ counter 2))
;; evaluate the tag
(compile-form throw-tag)
[
`(stw r28 (r29 ,(* counter 4)))
]
;; evaluate the form
(let ((*current-call-index* (+ counter 3)))
(compile-form throw-form))
;; peel off cleanup stack
(let ((dest temp))
(dolist (f *cleanup-forms-stack*)
(if (eq f dest) (return)) ;; returns from the dolist block
(case (car f)
(unwind-protect
;; include cleanup code
(let ((cleanup-code (cdr f)))
(dolist (n cleanup-code)
(push n *asm*))))
(catch
;; remove dynamic catch tag
[
`($CALL #'cl::%popCatcher) ;; restore result
]))))
[
`(mr r4 r28)
`(lwz r3 (r29 ,(* counter 4)))
`($CALL #'cl::%throwException) ;; call throw handler
]
(warn "Block label not found: ~A" block-name)
(return)))
;; peel off cleanup stack
(let ((dest temp))
(dolist (f *cleanup-forms-stack*)
(if (eq f dest) (return)) ;; returns from the dolist block
(case (car f)
(unwind-protect
;; include cleanup code
(let ((cleanup-code (cdr f)))
(dolist (n cleanup-code)
(push n *asm*))))
(catch
;; remove dynamic catch tag
[
`($CALL #'cl::%popCatcher) ;; restore result
]))))
[
`(b ,(caddr temp))
]))
(defun compile-progn-form (form)
(let ((progn-forms (cdr form)))
(dolist (f progn-forms)
(compile-form f))))
(defun compile-multiple-value-prog1-form (form)
(let ((progn-forms (cdr form))
(temp-var1 *lex-counter*)
(temp-var2 (+ *lex-counter* 1)))
;; if no forms, nothing to do
(if (null progn-forms)
(return))
;; if only a single form, just handle as a normal progn
(if (null (cdr progn-forms))
(progn
(compile-form (car progn-forms))
(return)))
;; make room for temp-vars on stack
(incf *lex-counter* 2)
(compile-form (car progn-forms))
;; store the result form and the multiple-value contents on stack
[
`(stw r3 (r30 ,(* temp-var1 4))) ; save result on stack
`($LOAD-LONG r3 cl::%multiple-values-address)
`(lwz r3 (r3))
`(stw r3 (r30 ,(* temp-var2 4))) ; save result on stack
]
;; compile the remaining forms
(setq progn-forms (cdr progn-forms))
(dolist (f progn-forms)
(compile-form f))
;; restore the first return value and any multiple values
[
`(lwz r28 (r30 ,(* temp-var1 4))) ;get result in R28
`($LOAD-LONG r3 cl::%multiple-values-address)
`(lwz r0 (r30 ,(* temp-var2 4)))
`(stw r0 (r3))
]
(setq *last-call-was-values* t)))
(defun compile-let-form (form)
(let* ((local-vars (cadr form))
(let-forms (cddr form))
(new-vars nil)
(special-vars nil)
(declarations nil)
(special-decs nil)
(counter *current-call-index*)
sym)
;; look for declarations
(do ((f let-forms (cdr f)))
((null f) (setq let-forms f))
(if (and (consp (car f)) (eq (caar f) 'declare))
(push (car f) declarations)
(progn (setq let-forms f) (return))))
;; search declarations for special declarations
(dolist (declaration declarations)
(dolist (dec-form (cdr declaration))
(if (and (consp dec-form) (eq (car dec-form) 'special))
(setq special-decs (append (cdr dec-form) special-decs)))))
;; go through variable list evaluating values and assigning to temporary
;; space on the stack
(dolist (f local-vars)
(unless (or (consp f) (symbolp f))
(error "Invalid 'let' variable"))
(if (or (symbolp f) (not (consp (cdr f))))
[
`($LOAD-OBJ r3 'nil)
`(stw r3 (r30 ,(* *lex-counter* 4)))
]
;; else
(let ((*current-call-index* counter))
(compile-form (cadr f))
[
`(stw r28 (r30 ,(* *lex-counter* 4)))
]))
;; add the symbol to the list of new symbols
(if (consp f)
(setq sym (car f))
(setq sym f))
(if (or (special-variable-p sym) (member sym special-decs))
(progn
(push sym special-vars)
[
`($LOAD-OBJ r3 ',sym)
`(stw r3 (r29 ,(* counter 4)))
`(lwz r3 (r30 ,(* *lex-counter* 4)))
`(stw r3 (r29 ,(* (1+ counter) 4)))
]
(incf counter 2))
;; else
(push (cons sym *lex-counter*) new-vars))
(incf *lex-counter*))
;; add the new variables to the lexical environment
(add-lexical-variables new-vars)
(create-runtime-bindings)
;; if any special variables are present, add those bindings now
(if special-vars
(progn
[
`(li r3 0)
`(stw r3 (r29 ,(* counter 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::$push-special-bindings)
]
(incf counter)
(parameter-ceiling counter)
(let ((*current-call-index* counter))
(compile-unwind-protect-form
`(unwind-protect
(progn ,@let-forms)
($pop-special-bindings ',special-vars)))))
;; else execute the forms directly
(dolist (f let-forms)
(compile-form f)))
;; restore old lexical environment
(pop-cleanup)))
(defun compile-let*-form (form)
(let* ((local-vars (cadr form))
(let-forms (cddr form))
(special-vars nil)
(declarations nil)
(special-decs nil)
sym
(counter *current-call-index*)
(lex-var-count 0))
;; look for declarations
(do ((f let-forms (cdr f)))
((null f) (setq let-forms f))
(if (and (consp (car f)) (eq (caar f) 'declare))
(push (car f) declarations)
(progn (setq let-forms f) (return))))
;; search declarations for special declarations
(dolist (declaration declarations)
(dolist (dec-form (cdr declaration))
(if (and (consp dec-form) (eq (car dec-form) 'special))
(setq special-decs (append (cdr dec-form) special-decs)))))
;; go through variable list evaluating values and assigning to temporary
;; space on the stack
(dolist (f local-vars)
(unless (or (consp f) (symbolp f))
(error "Invalid 'let*' variable: ~A~%" f))
(if (or (symbolp f) (not (consp (cdr f))))
[
`($LOAD-OBJ r3 'nil)
`(stw r3 (r30 ,(* *lex-counter* 4)))
]
;; else
(progn
(compile-form (cadr f))
[
`(stw r28 (r30 ,(* *lex-counter* 4)))
]))
;; add the symbol to the list of new symbols
(if (consp f)
(setq sym (car f))
(setq sym f))
(if (or (special-variable-p sym) (member sym special-decs))
(progn
(push sym special-vars)
(parameter-ceiling (+ counter 3))
[
`($LOAD-OBJ r3 ',sym)
`(stw r3 (r29 ,(* counter 4)))
`(lwz r3 (r30 ,(* *lex-counter* 4)))
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::$push-special-bindings)
])
;; else
(progn
(add-lexical-variables (list (cons sym *lex-counter*)))
(incf lex-var-count)))
(incf *lex-counter*))
(create-runtime-bindings)
;; if any special variables are present, add those bindings now
(if special-vars
(compile-unwind-protect-form
`(unwind-protect
(progn ,@let-forms)
($pop-special-bindings ',special-vars)))
;; else execute the forms directly
(dolist (f let-forms)
(compile-form f)))
;; restore old lexical environment
(dotimes (i lex-var-count)
(pop-cleanup))))
(defun compile-flet-form (form)
(let* ((local-funs (cadr form))
(flet-forms (cddr form))
(new-funs nil)
(declarations nil))
;; look for declarations
(do ((f flet-forms (cdr f)))
((null f) (setq flet-forms f))
(if (and (consp (car f)) (eq (caar f) 'declare))
(push (car f) declarations)
(progn (setq flet-forms f) (return))))
;; search declarations for special declarations
;;
;; ;; do we need to deal with special declarations here? RGC
;; (dolist (declaration declarations)
;; (dolist (dec-form (cdr declaration))
;; (if (and (consp dec-form) (eq (car dec-form) 'special))
;; (setq special-decs (append (cdr dec-form) special-decs)))))
;;
;; go through function list evaluating values and assigning to temporary
;; space on the stack
(dolist (f local-funs)
(unless (and (consp f) (consp (cdr f)))
(error "Invalid 'flet' function expression"))
(let* ((func-name (car f))
(func-args (cadr f))
(func-forms (cddr f)))
(compile-function-special-form
`(function (lambda ,func-args (block ,func-name ,@func-forms))))
[
`(stw r28 (r30 ,(* *lex-counter* 4)))
]
;; add the function name to the list of new functions
(push (cons func-name *lex-counter*) new-funs)
(incf *lex-counter*)))
;; add the new functions to the lexical environment
(add-lexical-functions new-funs)
(create-runtime-bindings)
;; execute the forms directly
(dolist (f flet-forms)
(compile-form f))
;; restore old lexical environment
(pop-cleanup)))
(defun compile-labels-form (form)
(let* ((local-funs (cadr form))
(flet-forms (cddr form))
(new-funs nil)
(declarations nil)
first-func-position)
;; look for declarations
(do ((f flet-forms (cdr f)))
((null f) (setq flet-forms f))
(if (and (consp (car f)) (eq (caar f) 'declare))
(push (car f) declarations)
(progn (setq flet-forms f) (return))))
;; search declarations for special declarations
;;
;; ;; do we need to deal with special declarations here? RGC
;; (dolist (declaration declarations)
;; (dolist (dec-form (cdr declaration))
;; (if (and (consp dec-form) (eq (car dec-form) 'special))
;; (setq special-decs (append (cdr dec-form) special-decs)))))
;;
(setq first-func-position *lex-counter*)
(dolist (f local-funs)
(unless (and (consp f) (consp (cdr f)))
(error "Invalid 'labels' function expression"))
(let* ((func-name (car f)))
(push (cons func-name *lex-counter*) new-funs)
(add-to-environment func-name) ;; debug
(incf *lex-counter*)))
;; add the new functions to the lexical environment
(add-lexical-functions (reverse new-funs))
;; go through function list evaluating values and assigning to temporary
;; space on the stack
(dolist (f local-funs)
(let* ((func-name (car f))
(func-args (cadr f))
(func-forms (cddr f))
(pos (cdr (find func-name new-funs :key #'car))))
(if (consp pos)
(setq pos (car pos)))
(compile-function-special-form
`(function (lambda ,func-args (block ,func-name ,@func-forms))))
(let ((temp (find-lex-function func-name))) ; check for lexical function
(if temp
(if (integerp (cdr temp))
[
;; `(stw r28 (r30 ,(* pos 4)))
`(stw r28 (r30 ,(* (cdr temp) 4)))
]
;; else
[
`(lwz r26 (r30 ,(* (cadr temp) 4)))
`(stw r28 (r26 4)) ;; store in CDR field of binding
])))))
(create-runtime-bindings)
;; execute the forms directly
(dolist (f flet-forms)
(compile-form f))
;; restore old lexical environment
(pop-cleanup)))
(defun compile-function-special-form (form)
(let ((func-form (cadr form)))
;; I don't think this will occur, but just in case, we can't
;; keep a reference to an anonymous function object.
(if (functionp func-form)
(error "Can't compile expression with anonymous function: ~A~%" form))
;; if a compiled lambda expression
(if (and (consp func-form) (eq (car func-form) 'lambda))
(let ((name nil)
(first-form (third func-form))
(counter *current-call-index*))
(if (and (consp first-form) (eq (first first-form) 'block))
(setq name (second (third func-form))))
;; create a new compiled function
(parameter-ceiling (+ counter 2))
(setq func-form (compile-lambda func-form name))
[
`($LOAD-OBJ r3 ',func-form)
`(stw r3 (r29 ,(* counter 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%copy-compiled-function)
`(mr r28 r3)
]
(create-runtime-bindings)
(export-environment)
(return)))
(unless (symbolp func-form)
(error "function special form: ~%Expected a symbol: ~A~%" func-form))
(let ((temp (find-lex-function func-form))) ; check for lexical function
(if temp
(if (integerp (cdr temp))
[
`(lwz r28 (r30 ,(* (cdr temp) 4)))
]
;; else
[
`(lwz r28 (r30 ,(* (cadr temp) 4)))
`($CDR r28)
])
;; else see if it is in the inherited environment
(if (find-in-environment func-form)
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
[
`(stw r31 (r29 ,(* counter 4)))
`($LOAD-OBJ r3 ',func-form)
`(stw r3 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%environment-get-function)
`(mr r28 r3)
])
;; else assume global function
(compile-function-call-form `(symbol-function ',func-form)))))))
(defun compile-catch-form (form)
(let ((catch-tag (cadr form))
(catch-forms (cddr form))
(exit-label (gensym))
(jmpbuf-addr *lex-counter*))
(push-cleanup (list 'CATCH catch-tag))
;; evaluate the tag
(compile-form catch-tag)
;; make room for jmp-buf on stack
(incf *lex-counter* *jmp_buf-size*)
[
;; pushCatcher(tag, jmp_buf)
`(mr r3 r28) ; tag
`(addi r4 r30 ,(* jmpbuf-addr 4)) ; jmp_buf
`($CALL #'cl::%pushCatcher)
;; setjmp(jmp_buf)
`(addi r3 r30 ,(* jmpbuf-addr 4))
`($CALL #'common-lisp::%setjmp)
;; if result != 0, we caught an exception
`(mr r28 r3)
`(cmpwi r3 0)
`(bne ,exit-label)
`($LOAD-OBJ r28 'nil)
]
(dolist (f catch-forms)
(compile-form f))
[
exit-label
]
(pop-cleanup)
;; popCatcher()
[
`($CALL #'cl::%popCatcher)
]))
(defun compile-throw-form (form)
(let ((throw-tag (cadr form))
(throw-form (caddr form))
(counter *current-call-index*))
(parameter-ceiling (+ counter 2))
;; evaluate the tag
(compile-form throw-tag)
[
`(stw r28 (r29 ,(* counter 4)))
]
;; evaluate the form
(let ((*current-call-index* (+ counter 3)))
(compile-form throw-form))
[
`(mr r4 r28)
`(lwz r3 (r29 ,(* counter 4)))
`($CALL #'cl::%throwException) ;; call throw handler
]))
(defun compile-unwind-protect-form (form)
(let ((protected-form (cadr form))
(cleanup-forms (cddr form))
(label1 (gensym))
(label2 (gensym))
(temp-var1 *lex-counter*)
(temp-var2 (+ *lex-counter* 1))
(temp-var3 (+ *lex-counter* 2))
(jmpbuf-addr (+ *lex-counter* 3)))
;; make room for jmp-buf and temp-var on stack
(incf *lex-counter* (+ *jmp_buf-size* 3))
[
;; pushCatcher(tag, jmp_buf)
`(li r3 0) ; 1st arg = tag (special tag 0)
`(addi r4 r30 ,(* jmpbuf-addr 4)) ; jmp_buf
`($CALL #'cl::%pushCatcher)
;; setjmp(jmp_buf)
`(addi r3 r30 ,(* jmpbuf-addr 4))
`($CALL #'common-lisp::%setjmp)
;; if result != 0, we caught an exception
`(mr r28 r3)
`(stw r3 (r30 ,(* temp-var1 4))) ; save result on stack
`(cmpwi r3 0)
`(bne ,label1)
]
;; generate code for cleanup forms
(let ((*asm* nil))
[
`(stw r28 (r30 ,(* temp-var2 4))) ; store result
`($LOAD-LONG r3 cl::%multiple-values-address)
`(lwz r3 (r3)) ; get current mv result
`(stw r3 (r30 ,(* temp-var3 4)))
`($CALL #'cl::%popCatcher)
]
(dolist (f cleanup-forms)
(compile-form f))
[
`(lwz r0 (r30 ,(* temp-var3 4)))
`($LOAD-LONG r3 cl::%multiple-values-address)
`(stw r0 (r3))
`(lwz r28 (r30 ,(* temp-var2 4)))
]
(setq *asm* (nreverse *asm*))
(push-cleanup (cons 'UNWIND-PROTECT *asm*)))
;; compile protected form
(compile-form protected-form)
[
label1
]
;; include cleanup code
(let ((cleanup-code (cdr (pop-cleanup))))
(dolist (n cleanup-code)
(push n *asm*)))
;; retrieve exception result
[
`(lwz r3 (r30 ,(* temp-var1 4)))
`(cmpwi r3 0)
`(beq ,label2)
;; continue thrown exception
`($CALL #'cl::%continueException)
label2
]))
;; for non toplevel eval-when forms
(defun compile-eval-when-form (form)
(if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
(error "'eval-when' form missing condition list."))
(let* ((conditions (cadr form)))
(if (or (member 'common-lisp::eval conditions)
(member :execute conditions))
(compile-progn-form (cons 'common-lisp::progn (cddr form)))
(compile-nil))))
(defun compile-multiple-value-call-form (form)
(let* ((func (cadr form))
(forms (cddr form))
(numforms (length forms))
(counter 0)
(temp-var1 *lex-counter*)
(dummy (+ *lex-counter* 1)) ; we need an open slot here
(call-params (+ *lex-counter* 2))
(pcounter *current-call-index*)
temp)
(parameter-ceiling (+ pcounter 3))
(incf *lex-counter* (+ numforms 3)) ; numforms + 2 vars + 0 terminator
(compile-form func)
[
`(stw r28 (r30 ,(* temp-var1 4))) ; save function address
]
(dolist (p forms) ; execute each form
(compile-form p)
[
`($IFELSE
(
($LOAD-LONG r3 cl::%multiple-values-address)
(lwz r0 (r3))
(cmpwi r0 0)
)
(
;; if no multiple values, just list the single value
(stw r28 (r29 ,(* pcounter 4)))
($LOAD-OBJ r0 'nil)
(stw r0 (r29 ,(* (+ pcounter 1) 4)))
(li r0 0)
(stw r0 (r29 ,(* (+ pcounter 2) 4)))
(addi r3 r29 ,(* *current-call-index* 4))
($CALL #'cons)
(mr r28 r3)
)
(
;; otherwise get the list of values
(mr r28 r0)
))
`(stw r28 (r30 ,(* (+ call-params counter) 4)))
]
(incf counter))
;; concatenate all the lists together and store in d3
[
`(li r0 0)
`(stw r0 (r30 ,(* (+ call-params counter) 4)))
`(addi r3 r30 ,(* call-params 4))
`($CALL #'append)
`(mr r28 r3)
]
;; now apply the passed function to the resulting value list
(setq pcounter *current-call-index*)
[
`(lwz r0 (r30 ,(* temp-var1 4))) ; get saved function address
`(stw r0 (r29 ,(* pcounter 4)))
`(stw r28 (r29 ,(* (+ pcounter 1) 4))) ; argument list
`(li r0 0)
`(stw r0 (r29 ,(* (+ pcounter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'apply)
`(mr r28 r3)
]))
(defun compile-the-form (form)
(let ((type (cadr form))
(expr (caddr form)))
(compile-form expr)))
(defun compile-values-form (form)
(compile-function-call-form form)
(setq *last-call-was-values* t))
(defun compile-function-call-form (form)
;;
;; ;; print warning message if function hasn't been defined yet
;; (if (not (functionp (symbol-function (car form))))
;; (format t "Warning: function ~A missing definition~%" (car form)))
;;
(if (or (find-lex-function (car form)) (find-in-environment (car form)))
(progn
(compile-function-call-form `(funcall (function ,(car form)) ,@(cdr form)))
(return)))
(let* ((numparams (1- (length form)))
(stackframe (* 4 (1+ numparams)))
(func (car form))
(funcparams (cdr form))
(counter (1+ *current-call-index*)) ;; save an extra space before params
(tail-recursive (if (eq func *function-name*) *asm*))
temp)
(dolist (p funcparams) ; get parameters for function call
(setf temp (find-lex p)) ; check for lexical variable
(if temp
(if (integerp (cdr temp))
[
`(lwz r0 (r30 ,(* (cdr temp) 4))) ; get lexical var
`(stw r0 (r29 ,(* counter 4))) ; store it as a parameter
]
;; else
[
`(lwz r3 (r30 ,(* (cadr temp) 4)))
`($CDR r3)
`(stw r3 (r29 ,(* counter 4)))
])
;; else
(let ((*current-call-index* counter))
(compile-form p) ; ignore multiple values in params
[
`(stw r28 (r29 ,(* counter 4)))
]))
(incf counter))
;; clear the last position to zero
[
`(li r3 0)
`(stw r3 (r29 ,(* counter 4)))
`(addi r3 r29 ,(* (1+ *current-call-index*) 4)) ; pass address of params to function
]
(incf counter)
(parameter-ceiling counter)
;; if it is a recursive call to this function, we need to handle it specially
(if (eq func *function-name*)
[
`(bl ,*function-entry-label*)
]
;; else
(progn
[
`($CALL #',func)
]))
[
`(mr r28 r3)
]
;; flag tail recursion
(setq *last-call-was-tail-recursion* tail-recursive)))
(defun compile-integer (form)
(if (typep form 'bignum)
(compile-bignum form)
[
`(lis r3 ,(cl::%fixnum-upper16 form))
`(ori r3 r3 ,(cl::%fixnum-lower16 form))
`($CALL #'common-lisp::%integerAtom)
`(mr r28 r3)
]))
(defun compile-bignum (num)
(let* ((numcells (cl::%bignum-cells num))
(length-flag (if (minusp num) (- numcells) numcells))
(temp-label (gensym)))
[
`(bl ,temp-label)
`(dc.l ,length-flag)
]
(dotimes (i numcells)
[
`(dc.l ,(cl::%bignum-cell num i))
])
[
temp-label
`(mflr r3)
`($CALL #'cl::%bignumAtomFromLongs)
`(mr r28 r3)
]))
(defun string-int-with-pad (string index)
(if (>= index (length string))
0
(char-int (elt string index))))
(defun compile-string (string)
(let* ((numchars (+ 1 (length string)))
n
temp
(num-longs (truncate (+ 3 numchars) 4))
(temp-label (gensym)))
[
`(bl ,temp-label)
]
(dotimes (i num-longs)
(setq temp (* i 4))
;; gather four characters into a long
(setq n
(+
(* (string-int-with-pad string temp) #x1000000)
(* (string-int-with-pad string (+ temp 1)) #x10000)
(* (string-int-with-pad string (+ temp 2)) #x100)
(string-int-with-pad string (+ temp 3))))
[
`(dc.l ,n)
])
[
temp-label
`(mflr r3)
`($CALL #'cl::%stringAtom)
`(mr r28 r3)
]))
;; need to add support for bit-vectors
(defun compile-literal-form (form)
(cond
((symbolp form) [ `($LOAD-OBJ r28 ',form) ])
((integerp form) (compile-integer form))
((stringp form) (compile-string form))
((characterp form) (compile-character form))
((listp form) (compile-quoted-list form))
((vectorp form) (compile-vector form))
((floatp form) (compile-float form))
((typep form 'ratio)(compile-ratio form))
((typep form 'complex)(compile-complex form))
;; we will have to code a direct reference to the object
;; This won't work if we use 'compile-file'.
(t [ `($LOAD-OBJ r28 ',form) ])))
(defun compile-character (form)
[
`(li r3 ,(char-int form))
`($CALL #'cl::%charAtom)
`(mr r28 r3)
])
;;
;; compile-quoted-list()
;; We catch and save the last form in case we are dealing with
;; a dotted list or dot pair.
;;
(defun compile-quoted-list (form &aux (last-element (cdr (last form))))
(let ((list-length (length form))
(counter *current-call-index*))
(parameter-ceiling (+ counter list-length 2))
(setq form (copy-list form)) ; replaces last cdr with nil
(dolist (f form)
(let ((*current-call-index* counter))
(compile-literal-form f))
[
`(stw r28 (r29 ,(* counter 4)))
]
(incf counter))
(let ((*current-call-index* counter))
(compile-literal-form last-element))
[
`(stw r28 (r29 ,(* counter 4)))
`(li r0 0)
`(stw r0 (r29 ,(* (+ counter 1) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::list*)
`(mr r28 r3)
]))
;;
;; compile-vector()
;;
(defun compile-vector (form)
(setq form (concatenate 'list form))
(let ((list-length (length form))
(counter *current-call-index*))
(parameter-ceiling (+ counter list-length 1))
(dolist (f form)
(let ((*current-call-index* counter))
(compile-literal-form f))
[
`(stw r28 (r29 ,(* counter 4)))
]
(incf counter))
[
`(li r0 0)
`(stw r0 (r29 ,(* counter 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::vector)
`(mr r28 r3)
]))
;; define these in order to get at the binary representation of a floating
;; point number so that we can generate the machine code to build it.
;; These functions don't check their type, so we get get the data.
(defasm %fp-upper-32 (x)
#{
($FUNC-BEGIN 200)
(lwz r3 (r3))
(lwz r3 (r3))
($CALL #'cl::%createInteger)
($RETURN r3 200)
})
(defasm %fp-lower-32 (x)
#{
($FUNC-BEGIN 200)
(lwz r3 (r3))
(lwz r3 (r3 4))
($CALL #'cl::%createInteger)
($RETURN r3 200)
})
;;
;; compile-float()
;;
(defun compile-float (form)
(let ((temp-label (gensym)))
[
`(bl ,temp-label)
`(dc.l ,(%fp-upper-32 form))
`(dc.l ,(%fp-lower-32 form))
temp-label
`(mflr r3)
`(lfd fp1 (r3))
`($CALL #'cl::%floatAtom)
`(mr r28 r3)
]))
;;
;; compile-ratio()
;;
(defun compile-ratio (form)
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
(compile-form (numerator form))
[
`(stw r28 (r29 ,(* (+ counter 0) 4)))
]
(let ((*current-call-index* (+ counter 1)))
(compile-form (denominator form)))
[
`(stw r28 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::/)
`(mr r28 r3)
]))
;;
;; compile-complex()
;;
(defun compile-complex (form)
(let ((counter *current-call-index*))
(parameter-ceiling (+ counter 3))
(compile-form (realpart form))
[
`(stw r28 (r29 ,(* (+ counter 0) 4)))
]
(let ((*current-call-index* (+ counter 1)))
(compile-form (imagpart form)))
[
`(stw r28 (r29 ,(* (+ counter 1) 4)))
`(li r3 0)
`(stw r3 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::complex)
`(mr r28 r3)
]))
(defun check-lambda (lambda)
(let ((lambda-list (cadr lambda)))
(dolist (n lambda-list)
(if (member n *unsupported-lambda-list-keywords*)
(error "Can't compile this lambda list keyword: ~A~%" n)))))
(defun find-lex (var)
(let (found)
(dolist (n *cleanup-forms-stack* nil)
(if (eq (car n) 'LET)
(progn
(setq found (assoc var (cdr n)))
(if found (return-from find-lex found)))))))
(defun find-lex-function (var)
(let (found)
(dolist (n *cleanup-forms-stack* nil)
(if (eq (car n) 'FLET)
(progn
(setq found (assoc var (cdr n)))
(if found (return-from find-lex-function found)))))))
(defun find-go-tag (var)
(let (found)
(dolist (n *cleanup-forms-stack* nil)
(if (eq (car n) 'TAGBODY)
(progn
(setq found (assoc var (cdr n)))
(if found (return-from find-go-tag found)))))))
;;
;; find-go-tag-tagbody
;; Returns the cleanup form for the TAGBODY block which contains the
;; passed tag.
;;
(defun find-go-tag-tagbody (var)
(let (found)
(dolist (n *cleanup-forms-stack* nil)
(if (eq (car n) 'TAGBODY)
(progn
(setq found (assoc var (cdr n)))
(if found (return-from find-go-tag-tagbody n)))))))
(defun find-block (name)
(dolist (n *cleanup-forms-stack* nil)
(if (eq (car n) 'BLOCK)
(if (eq (cadr n) name)
(return-from find-block n)))))
(defun find-any-block ()
(dolist (n *cleanup-forms-stack* nil)
(if (eq (car n) 'BLOCK)
(return-from find-any-block n))))
(defun parameter-ceiling (n)
;; keep track of how large a parameter frame we need
(if (> n *max-call-parameters*)
(setq *max-call-parameters* n)))
;;
;; required-arguments
;; Returns a list of the required arguments in a lambda list.
;;
(defun required-arguments (lambda-list)
(let ((arglist nil))
(dolist (n lambda-list)
(if (member n *lambda-list-keywords*)
(return) ;; exit dolist loop
(push n arglist)))
(nreverse arglist)))
;;
;; optional-arguments
;; Returns a list of the optional arguments in a lambda list.
;;
(defun optional-arguments (lambda-list)
(let ((arglist nil))
(dolist (n (cdr (member '&optional lambda-list)))
(if (member n *lambda-list-keywords*)
(return) ;; exit dolist loop
(push n arglist)))
(nreverse arglist)))
;; we don't need this
;;
;;(defun get-supplied-p-args (lambda-list)
;; (let ((args nil) (forms (optional-arguments lambda-list)))
;; (dolist (f forms)
;; (if (>= (length f) 3)
;; (push (list (caddr f) nil) args)))
;; (reverse args)))
;;
;; rest-arguments
;; Returns a list of the rest arguments in a lambda list.
;;
(defun rest-arguments (lambda-list)
(let ((arglist nil))
(dolist (n (cdr (member '&rest lambda-list)))
(if (member n *lambda-list-keywords*)
(return) ;; exit dolist loop
(push n arglist)))
(nreverse arglist)))
;;
;; key-arguments
;; Returns a list of the optional key in a lambda list.
;;
(defun key-arguments (lambda-list)
(let ((arglist nil))
(dolist (n (cdr (member '&key lambda-list)))
(if (member n *lambda-list-keywords*)
(return) ;; exit dolist loop
(push n arglist)))
(nreverse arglist)))
;;
;; aux-arguments
;; Returns a list of the aux arguments in a lambda list.
;;
(defun aux-arguments (lambda-list)
(let ((arglist nil))
(dolist (n (cdr (member '&aux lambda-list)))
(if (member n *lambda-list-keywords*)
(return) ;; exit dolist loop
(push n arglist)))
(nreverse arglist)))
;;
;; kill-multiple-values
;; Use this function to make sure that ignored multiple values don't stick
;; around through successive evaluations.
;;
(defun kill-multiple-values ()
[
`($LOAD-LONG r3 cl::%multiple-values-address)
`(li r0 0)
`(stw r0 (r3))
])
(defun compile-nil ()
[ `($LOAD-OBJ r28 'nil) ]
(setq *last-call-was-values* nil))
(defun valid-lambda (x)
(and (listp x) (> (length x) 2) (eq (car x) 'lambda) (listp (cadr x))))
(defun find-lambdas (x)
(cond ((not (consp x)) nil)
((valid-lambda x) (list x))
((eq (car x) 'FLET) (cadr x))
((eq (car x) 'LABELS) (cadr x))
((eq (car x) 'DEFUN) (list x))
((eq (car x) 'DEFMACRO) (list x))
(t (append (find-lambdas (car x)) (find-lambdas (cdr x))))))
(defun add-lexical-variables (varlist)
(push-cleanup (cons 'LET varlist)))
(defun add-lexical-functions (varlist)
(push-cleanup (cons 'FLET varlist)))
(defun search-lambdas (var lambdas)
(cond ((null lambdas) nil)
((eq var lambdas) var)
((atom lambdas) nil)
((search-lambdas var (car lambdas)))
((search-lambdas var (cdr lambdas)))))
(defun referenced-by-embedded-lambdas (var)
(search-lambdas var *embedded-lambdas*))
(defun create-runtime-bindings ()
(if *embedded-lambdas*
(dolist (n *cleanup-forms-stack*)
(if (or (eq 'LET (car n)) (eq 'FLET (car n)))
(dolist (m (cdr n))
(let* ((sym (car m))
(index (cdr m)))
(if (and (integerp index)
(referenced-by-embedded-lambdas sym))
(let ((counter *current-call-index*))
(setf (cdr m) (list index))
(add-to-environment sym)
(parameter-ceiling (+ counter 3))
[
;; add a heap binding for the variable
`($LOAD-OBJ r3 ',sym)
`(lwz r4 (r30 ,(* index 4)))
`($CALL #'cl::%cons)
`(stw r3 (r30 ,(* index 4)))
#| ;; add a heap binding for the variable
`($LOAD-OBJ r0 ',sym)
`(stw r0 (r29 ,(* counter 4)))
`(lwz r0 (r30 ,(* index 4)))
`(stw r0 (r29 ,(* (+ counter 1) 4)))
`(li r0 0)
`(stw r0 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::cons)
`(stw r3 (r30 ,(* index 4)))
|#
]))))))))
;;
;; export-environment()
;; r28 points to the function to receive the environment
;;
(defun export-environment ()
;; first copy our heap environment
(let ((counter *current-call-index*)
(temp-var1 *lex-counter*))
(incf *lex-counter*)
(parameter-ceiling 3)
[
`(stw r28 (r29 ,(* counter 4))) ; target function
`(stw r31 (r29 ,(* (+ counter 1) 4))) ; our environment
`(li r0 0)
`(stw r0 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%function-environment) ; copy it
]
;; now get the target environment in r3
[
`(stw r28 (r29 ,(* counter 4))) ; target function
`(li r0 0)
`(stw r0 (r29 ,(* (+ counter 1) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%function-environment) ; get its environment
]
;; now add all our current heap bindings
(if *embedded-lambdas*
(dolist (n *cleanup-forms-stack*)
(if (eq 'LET (car n))
(dolist (m (cdr n))
(let* ((sym (car m))
(index (cdr m)))
(if (consp index)
[
;; add the binding to the target environment
`(stw r3 (r30 ,(* temp-var1 4))) ; save environment
`(stw r3 (r29 ,(* counter 4))) ; environment
`(lwz r0 (r30 ,(* (car index) 4)))
`(stw r0 (r29 ,(* (+ counter 1) 4)))
`(li r0 0)
`(stw r0 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%environment-add-binding)
`(lwz r3 (r30 ,(* temp-var1 4))) ; get environment
]))))))
(if *embedded-lambdas*
(dolist (n *cleanup-forms-stack*)
(if (eq 'FLET (car n))
(dolist (m (cdr n))
(let* ((sym (car m))
(index (cdr m)))
(if (consp index)
[
;; add the binding to the target environment
`(stw r3 (r30 ,(* temp-var1 4))) ; save environment
`(stw r3 (r29 ,(* counter 4))) ; environment
`(lwz r0 (r30 ,(* (car index) 4)))
`(stw r0 (r29 ,(* (+ counter 1) 4)))
`(li r0 0)
`(stw r0 (r29 ,(* (+ counter 2) 4)))
`(addi r3 r29 ,(* *current-call-index* 4))
`($CALL #'cl::%environment-add-function-binding)
`(lwz r3 (r30 ,(* temp-var1 4))) ; get environment
]))))))))
(defun add-to-environment (sym) (push sym *environment*))
(defun find-in-environment (sym) (member sym *environment*))
(defun environment-not-empty () *environment* )
) ;; close beginning eval-when